perm filename ITMSBX.F4[MSS,LCS]1 blob sn#091403 filedate 1974-03-19 generic text, type T, neo UTF8
00010	C**** ITMSUB, RNOTE ********
00100	C  ********** WHOLE & HALF RESTS, BEAMS ******
00300		SUBROUTINE ITMSUB
00400		IMPLICIT INTEGER(A-Q,S-Z)
00500		REAL DIS,PWDS,DISX,HGT,POS,CENTR,STFF,HGT1
00600		COMMON/STF/RSTFAC(8),RSTJC/MIN/MINI,RMINI
00800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/BM/RA,RC,RJY
00900		COMMON/POSI/STFF(8),JJB,POS/PLTR/PLT,RHT,DIS
01100		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
01200		1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
01300		1,(JK,JQ(9)),(JF,JQ(4)),(RJI,RJQ(7)),(RJH,RJQ(6))
01400		1 ,(RJG,RJQ(5)),(RJD,RJQ(2)),(RJI,RJQ(7)),(RJJ,RJQ(8))
01500		DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/
01600		RST7=RSTJC*7.
01700		RST18=RSTJC*18.
01750	C  TO COMPENSATE FOR NOTE #3 COMING AT POS=0
01800	
01900		RJBQ=JB
02000		JY=0
02100		IF(JA.EQ.9)GO TO 90
02250		IF(JA.EQ.10)GO TO 100
02275	C  GO TO LINES, BEAMS, STAVES.
02300	C   NEXT DRAWS STRAIGHT LINES
02400	
02500		RD=RJD*RST7
02600		RA=0
02710	C WHY "*RSTJC"????
02755		RX=RTF+POS
02800		IF(JE.EQ.50)GO TO 300
02900		IF(RJF.GT.0)GO TO 401
03000	C  FOR BAR LINES
03050		JA=44
03075	C  CODE # IS CHNGD SO BAR LINES WON'T AFFECT MAX. HGT.
03100		IF(JG)GO TO 407
03110		IF(JG.EQ.0)JG=JD/100
03200		RX=RTF*RSTJC+POS
03250		L=MOD(JD,100)+JC+3
03300	C JD=401 MAKES 4X THICK BARLINE - ONE STAFF
03350		RY=STFF(L)+.5+RSTFAC(L)*58.
03400		RW=RY
03500		RJX=RJBQ
03700	42	CALL LINES(RJBQ,RX,3)
03800		IF(JG.EQ.-2)GO TO 404
03900	C  IF JG<0 THEN WIGGLEY LINES ARE MADE.
04000	406	CALL LINES(RJX,RY,2)
04100		IF(JG.EQ.0)GO TO 43
04200	C  FOR 'HEAVY' LINE.
04300		JG=JG-1
04400		RY=RW
04500		IF(MOD(JG,2).EQ.0)GO TO 406
04600		RY=RX
04700		RJX=RJX+1
04800		GO TO 406
05000	43	IF(RA.GT.0)GO TO 403
05100		RETURN
05200	C   HOV IS RA.NE.0?
05300	C  DRAWS BAR LINES. JD>0 CAUSES FULL LINE.
05400	403	RA=RA-3.72
05500		RJBQ=RJBQ+22
05600		RJX=RJX+22
05700	C   DO ABOVE NEED *RSTJC? ************
05800	C **** BASED ON '596' ****
05900		GO TO 42
06000	
06100	C  FOR CRESC., DECRESC.
06200	300	RA=ABS(RJG/2.0)*RST7
06300	C   AMOUNT OF SPREAD
06400		RJ=RJBQ
06600		RX=RX-RST18+RD
06610		IF(RJH.NE.0)GO TO 302
06620	C  JUMP TO MAKE BOX
06690		RJF=RHORZ(RJF)
06700		IF(RJG)GO TO 301
06800		RJ=RJF
06900		RJF=RJBQ
07150	301	CALL LINX(RJ,RX+RA,RJF,RX)
07200		CALL LINES(RJ,RX-RA,2)
07300	C  FOR CRESC, DECRESC: 4 POS1, STF, HGT, 50, POS1, +OR-N
07400		RETURN
07405	
07410	302	RJH=RJH*RST7
07412		RJI=RJI*RST7
07415		IF(RJI.EQ.0)RJI=RJH
07420		RJB=RJBQ-RJH/2.
07430		RX=RX-RJI/2.
07440	C  DRAWS BOX, CENTER IS IN MIDDLE 
07445	C  4,POS,STF,NT#,50,0,0,,SIZ1[BY NT#S],SIZ2
07465		CALL LINX(RJB,RX,RJB+RJH,RX)
07470		CALL LINES(RJB+RJH,RX+RJI,2)
07480		CALL LINES(RJB,RX+RJI,2)
07490		CALL LINES(RJB,RX,2)
07495		RETURN
07500	
07600	C  DASHES
07610	401	POS=POS-RST18
07620	C********* 27/9/72 ******
07700		IF(JG.EQ.0)GO TO 407
07710		IF(ABS(RJF-RJB).LT..01)GO TO 402
07715	C VERTICAL DASHES IF P6=P2
07800		RA=RJF-RJB-4.
07900		RJF=RJB+2
08000		IF(JG.GT.0)JG=0
08010		GO TO 407
08020	402	RA=POS+RJE*RST7
08025		IF(RJH.EQ.0)RJH=.8
08027	C  P8 CAN SET SIZE OF DASH
08030		RJ=RJH*RST7
08038		RX=RD+POS
08047		L=3
08048		K=2
08050	41	IF(RX.GT.RA)RETURN
08052	C  DASHES MUST GO FROM BOTTOM TO TOP.
08055		CALL LINES(RJBQ,RX,L)
08060		RX=RX+RJ
08075		CALL EXCH(K,L)
08080		GO TO 41
08300	407	RX=RD+POS
08400		RY=RJE*RST7+POS
08500		IF(JG.EQ.-1)GO TO 408
08600	C  FOR 'TR' JG=-2, 'ARPEGG' JG=-1
08700		RJX=IFIX(RHORZ(RJF))
08850		GO TO 42
08900	C  DRAWS STRAIGHT LINES. ETC.
09000	404	L=(RA+4)/1.5
09100		RJ=RY
09200		DO 405 K=1,L
09300		CALL LINES(RJX,RJ,2)
09450		RJX=RJX+9
09500	C   *RSTJC?
09800	405	CALL EXCH(RX,RJ)
09900		RETURN
10000	
10100	408	IF(RX.GT.RY)CALL EXCH(RX,RY)
10500		RX=RX-12.*RSTJC
10550		RJ=6.*RSTJC
10600		RJX=4*RSTJC
10650		RW=RJBQ-RJX
10700		CALL LINES(RW,RX-RJ,3)
10800	410	CALL LINES(RJBQ+RJX,RX,2)
10900		CALL LINES(RW,RX+RJ,2)
11000		RX=RX+12.*RSTJC
11100		IF(RX.LT.RY)GO TO 410
11200		RETURN
11300	C  VERTICAL WIGGLE
11400	
11500	
11600	C  NEXT IS FOR BEAMS
11610	90	RMINI=RSTJC
11625		RX=2.7*RSTJC
11645	C******************************
11650		IF(JJ.LT.10)GO TO 91
11660	C NEXT FOR INNER, PARTIAL BEAMS
11670		RJJ=AMOD(RJJ,10.)
11675		GO TO(2,3,4),JJ/10
11680	2	RJH=RJI+RX
11685		GO TO 4
11690	3	RJH=RJI-RX
11697	C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
11700	4	RH=RHORZ(RJH)
11705	C  LEFT INNER POS.
11707		GO TO 1
11709	C******************************
11710	91	IF(JH.GE.0)GO TO 1
11730	92	RJI=RJB+RX
11740		IF(JH.LE.-20)RJI=RJF-RX
11750	192	JH=-JH
11760		IF(JJ.EQ.0)JJ=MOD(JH,10)
11762		JH=JH-JJ
11765		IF(JJ.EQ.0)JJ=1
11770		RJJ=JJ
11782	C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
11800	1	IF(IABS(JD).LT.100)GO TO 97
11900		RMINI=.6*RSTJC
12100		RJE=AMOD(RJE,100.0)
12112	C   SPACE BETWEEN BEAMS
12115	97	RJ=RMINI*11.
12120		RW=RMINI*RHGT
12122	C  DIST. UP OR DOWN FROM NOTE HEAD.
12130		RJA=RJJ*RJ
12165	C  DISPLACEMENT
12200		RD=RHORZ(ABS(RJI))
12250	C  POSITION 3
12300		RJX=CENTR-RW+RJA
12400	C  FINAL HEIGHT
12500	CC??????	RX=MOD(JG,10)-MOD(JH,10)
12550		RX=MOD(JG,10)
12600		JJB=JG-20
12700		RA=RHORZ(RJF)
12750	C  HORIZANTAL DIST.
12800		RJY=RJE*RST7+POS-RST18-RW+RJA
12900	C************************
13010		RW=R14*RMINI
13100		IF(JG.GE.20)GO TO 93
13150	C JUMP IF STEMS ARE DOWN
13200		JJB=JG-10
13300		RJ=-RJ
13310	CCAUG.7,73	RJA=RMINI*R2HGT-2.*RJA-3.
13315		RY=-3
13317		IF(RMINI.LT..65)RY=-1
13320		RJA=RMINI*R2HGT-2.*RJA+RY
13400		RJX=RJX+RJA
13500		RJY=RJY+RJA
13600		RJBQ=RJBQ+RW
13650	C  POSITION 1
13700		RA=RA+RW
13750	C  POSITION 2
13800		RD=RD+RW
13810	C******************************
13820		RH=RH+RW
13900	93	IF(JJB.GT.RX)GO TO 94
13910		IF(JJ.GE.10)GO TO 7
14000	C**********************
14100		IF(JH.EQ.0)GO TO 94
14200		RJC=RW
14210	C******************************
14300		IF(RJI.EQ.0)GO TO 292
14400	 	IF(JH.GE.20)GO TO 193
14410	C******************************
14420	CC	IF(JI.GT.0)GO TO 293
14500	293	RX=RJBQ-RD
14600		GO TO 194
14610	C******************************
14620	7	RHX=RH-RJBQ
14630	CC	RJC=RX-RJBQ
14635		RJC=RD-RJBQ
14640		GO TO 292
14700	193	RX=RD-RA
14800	194	RJC=ABS(RX)
14900	292	DISX=ABS(RJBQ-RA)
15100		HGT=RJX-RJY
15110		IF(JJ.GE.10)HGT1=HGT*RHX/DISX
15200	C**********************
15300		RJC=RJC/DISX
15750	195	HGT=HGT*RJC
15800	196	L=JH/10
15900		JH=0
16000		IF(L.EQ.1)GO TO 95
16010		IF(JJ.GE.10)GO TO 8
16020	C***************
16100	C   BEAM LFT=1,  RT=2   (PARAM 8=10 OR 20)
16200		RJBQ=RD
16300		RJX=RJY+HGT
16400		GO TO 94
16410	C**************
16420	8	RJBQ=RH
16430		RA=RD
16440		RJY=RJX-HGT
16450		RJX=RJX-HGT1
16460		GO TO 94
16500	95	RA=RD
16600		RJY=RJX-HGT
16700	94	RC=0
16800		L=4
16900		IF(RMINI.LT..65)L=2
17000		CALL LINES(RJBQ,RJX,3)
17100		DO 941 K=1,L
17200		CALL BMS
17250		IF(PLT.GE.0)GO TO 940
17300		RC=RC+1
17400		CALL BMS
17500		CALL EXCH(RA,RJBQ)
17600	941	CALL EXCH(RJY,RJX)
17700		CALL BMS
18000	C  DRAWS 5 LINES FOR BEAMS.
18100	940	JJB=JJB-1
18200		IF(JJB.LE.0)RETURN
18300	C  IF P7=10 OR 20 ONE BEAM WILL APPEAR.
18400		RJY=RJY+RJ
18500		RJX=RJX+RJ
18600		GO TO 93
18700	
18900	100	RA=0
19000		RJB=RHORZ(RJB)
19100		RJ=RHORZ(FLOAT(JD))
19200		IF(JD.EQ.0)RJ=596
19300	C  FOR STAFF LINES: 10, POS 1, HGT(3 TO -3), 2ND POS., UP-DOWN(NT #S)
19310		JC=JC+4
19350		IF(RJF.EQ.0)RJF=RSTFAC(JC)
19400		IF(RJF.EQ.0)RJF=1.
19600		RSTFAC(JC)=RJF
19700		STFF(JC)=(JC-1)*123-369.+RJE*7.*RJF
19800		RX=STFF(JC)+RTF*RJF
19850	C  FOR RTF SEE DATA
20150	C  FOR 2 PASS PLOTTING
20800		RJF=RJF*14.
20900		DO 6 K=1,5
21000		RZ=RJ
21100		RW=RJB
21200		IF(K.EQ.2.OR.K.EQ.4)CALL EXCH(RW,RZ)
21650		CALL LINX(RZ,RX,RW,RX)
21700	6	RX=RX+RJF
21900		END
22000	
22010		SUBROUTINE BMS
22020		COMMON/STF/RSTFAC(8),RSTJC/BM/RA,RC,RJY
22030		CALL LINES(RA,RJY+RC*RSTJC,2)
22040		END
22100	
22200		SUBROUTINE METER
22600		COMMON /STF/RSTFAC(8),RSTJC
22700		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
23000		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
23100		1,(RJF,RJQ(4)),(JF,JQ(4)),(RJE,RJQ(3)),(RJG,RJQ(5))
23200		1,(RJH,RJQ(6)),(RJG,RJQ(5))
23300	
23400	C  PARAMS  18 / POS / STF / TOP NUM/ BOT NUM/ VERT.HGT/ SIZE FAC.
23500	
23600		KC=10.*RSTJC+JB
23700		JX=JB
23800		JA=5
23900		RJE=RJG
24000		IF(RJE.EQ.0)RJE=1.
24100		IF(JD.GT.9)GO TO 10
24200		IF(JE.GT.9)GO TO 20
24300		M=2
24400		JF=JD
24500	19	RJD=(8.+RJF)*RJE
24600	C   MULTS BY SIZE FACTOR
24700	9	CALL NOTWRT
24800		GO TO (1,2,3,4,5),M
24900	1	RETURN
25000	
25100	C  ****** 4/(4) *****
25200	2	JF=JE
25300		M=1
25400	11	RJD=(4.+RJF)*RJE
25500		GO TO 9
25600	
25700	C ******* (1)2/16 *******
25800	10	JF=JD/10
25900		M=3
26000		GO TO 19
26100	
26200	C ****** 1(2)/16 *******
26300	3	M=4
26400	39	JB=JB+20.*RSTJC
26500		JF=MOD(JD,10)
26600		GO TO 9
26700	
26800	4	IF(JE.LT.9)GO TO 30
26900	C ******** 12/(1)6 ******
27000		JB=JX
27100		JF=JE/10
27200		M=5
27300		GO TO 11
27400	
27500	C ******* 12/1(6) ********
27600	5	JD=JE
27700		M=1
27800		GO TO 39
27900	
28000	C ********* 12/(8) ********
28100	30	JB=KC
28200		GO TO 2
28300	
28400	C ******** 4/16 *******
28500	20	M=4
28600		JB=KC
28700		JF=JD
28800		GO TO 19
28900		END
29000	
29100		SUBROUTINE RNOTE(X)
29200		COMMON /PTR/PWDS(250),ITEM,L,I,IX/XRN/RN(4000)
29300		X=RN(IFIX(PWDS(IFIX(AMOD(X,1000.))))+2)
29400		END